Magnum One/Magnum One (Mid-American Digital) (Disc Manufacturing).iso/d12/ddj0190.arc/TRACY.LST

File List | 1989-12-19 | 42KB | 1,269 lines

SCREEN 0
\ ZEN version 1.60-- a simple classical Forth
  ZEN 1.60 is a model implementation of the unofficial
  ANS Forth with Double-Number, File Access, and BLOCK
  Standard Extensions (BASIS6). This model is not endorsed
  by the ANS X3J14 committee. { Comments to go back to the ANS committee look
  like this.} ZEN 1.60 generates an IBM PC 64K small-model ROM-able nucleus.
  BX register is top-of-stack.  DTC with JMP code field.
  Assumes segment registers  CS = DS = ES Thanks to Wil Baden for his
  suggestions. This is a working document.  No guarantees are made to its
  accuracy or fitness.  While this is a working document, it is
  copyrighted 1989 by Martin J. Tracy.  All rights are reserved.

SCREEN 1
\ ZEN nucleus
FORTH DEFINITIONS  8 K-OF-ROM !  " KERNEL.COM" MAKE-OBJECT

32  CONSTANT #Jot    ( number conversion area in bytes)
128 CONSTANT #Safe   ( CREATE safety area--   in bytes)
128 CONSTANT #User   ( total user area size-- in bytes)

HEX
0100 BFFF 2DUP 2CONSTANT #ROM  ROMORG 2!  ( start & end of ROM)
C000 FFFF 2DUP 2CONSTANT #RAM  RAMORG 2!  ( start & end of RAM)
0000 #User - CONSTANT #RP0  ( top of return stack)
#RP0  0080 - CONSTANT #SP0  ( top of data   stack)

START   DECIMAL 2 LOAD   FINIS

SCREEN 2
\ Main LOAD screen
HERE EQU Power  2 CELLS ( power-up) GAP   ," C 1989 by M Tracy"
HERE EQU D0   #ROM , ,  #RAM , ,
HERE EQU H0 ( h) 0 ,    HERE EQU F0  0 , 0 ,  ( forth vlink)
HERE EQU T0 ( r) 0 ,    HERE EQU S0   #SP0 ,

           7 17 THRU  ( Kernel primitives)
          19 27 THRU  ( Numbers and I/O)
          29 41 THRU  ( Interpreter)
          43 69 THRU  ( Compiler)
          71 75 THRU  ( Device dependencies)
          81 86 THRU  ( Mass storage extension)
          77 79 THRU  ( Initialization)
                      ( Application, if any)

HERE H0 !   THERE T0 !

SCREEN 3
\ Documentation requirements
ZEN 1.60 supports Double-Number, File Access, and BLOCK Standard Extensions.
To compile the BLOCK extension, load the two screens following the File Access
extension. There are two 8-bit bytes per cell. Counted strings may be as long
as 255 bytes. Division is rounded-down. To change to floored division, load the
two screens following the mixed-precision rounded-down operators. The system
dictionary is approximately 7K address units (au's) leaving 56K for the
application. {#RAM and #ROM are currently set for 40K of application dictionary
and 16K of RAM.} {The data stack grows downwards towards the bottom of RAM.}
{The return stack is currently set for 128 au's of RAM.} Only dumb (glass)
terminals are supported. { How are minimum facilities to be specified?}

SCREEN 4
\ Errors and exceptions
If the input stream is inadvertantly exhausted: ABORT" ?"
If a word is not found: ABORT" ?"
If control structures are incorrectly nested: ABORT" Unbalanced"
If insufficient space in the dictionary: ABORT" No Room"
If insufficient number of stack entries: ABORT" Stack?"
If FORGETing within the nucleus: ABORT" Can't"

Division by zero returns a quotient of zero and a remainder
equal to the dividend.
Data and return stack overflows are not detected: the system
may crash or hang, if you are lucky.
Execution of compiler words while interpreting is not prevented;
the result of such execution is undefined.
Invalid and out-of-range arguments are not checked: the result
of using such arguments is very undefined.

SCREEN 5
\ Key to auxiliary commands
Several words used by the metacompiler are described here.

|              make the next word headerless.
," ccc"        compile the characters "ccc."

a ORG          reset HERE to address a.
n EQU <name>   equivalent to a headerless constant with value n.
LABEL <name>   equivalent to  HERE EQU <name> but also activates
               the CODE assembler.
CODE <name>    begins a machine-code definition, usually ended
               by  END-CODE  or  C;

I> and >I      like R> and >R when used to get return addresses.

BASE is returned to DECIMAL after each block is LOADed.

SCREEN 6
 --------------------------------------------------------------
|                                                              |
|  Please direct all comments and inquiries to Martin Tracy    |
|                                                              |
|                                                              |
 --------------------------------------------------------------

SCREEN 7
\ ------ Kernel primitives ------------------------
LABEL colon   BP DEC  BP DEC   SI 0 [BP] MOV   SI POP   NEXT
\ save I register on return stack and set it to new position.
\ This is the action of the code field in all colon definitions.

CODE EXIT   NOP
| CODE semi   0 [BP] SI MOV   BP INC  BP INC
| CODE nope   NEXT C;
\ semi is the action of the semicolon in all colon definitions.
\ EXIT differs from semi as an aid to decompilation.
\ nope is a "no operation" word used for initialization.


SCREEN 8
\ Data objects
LABEL addr  \ the action of all CREATEs.
   BX PUSH   3 # AX ADD  BX AX XCHG   NEXT

LABEL con   \ the action of all CONSTANTs and VARIABLEs.
   BX PUSH   3 # AX ADD  BX AX XCHG   0 [BX] BX MOV   NEXT C;

VARIABLE u  { Private}  \ USER area pointer.
LABEL uvar  \ the action of all USER variables.
   BX PUSH   3 # AX ADD   BX AX XCHG
   0 [BX] BX MOV   u ) BX ADD   NEXT

LABEL (does)   BP DEC  BP DEC  SI 0 [BP] MOV  \ run-time DOES>
   SI POP  BX PUSH   3 # AX ADD   BX AX XCHG    NEXT C;

SCREEN 9
\ Stack manipulation
CODE DUP  ( w - w w)   BX PUSH   NEXT C;
CODE DROP ( w)         BX POP    NEXT C;

CODE SWAP ( w w2 - w2 w)
   SP DI MOV             BX 0 [DI] XCHG   NEXT C;
CODE OVER ( w w2 - w w2 w)
   SP DI MOV   BX PUSH   0 [DI] BX MOV    NEXT C;

CODE ROT ( w w2 w3 - w2 w3 w)
   DX POP  AX POP   DX PUSH  BX PUSH   AX BX MOV   NEXT C;

CODE PICK ( w[u]...w[1] w[0] u - w[u]...w[1] w[0] w[u])
\ copy kth item to top of stack.
   BX SHL   SP BX ADD   0 [BX] BX MOV   NEXT C;

SCREEN 10
\ Memory access
CODE @ ( a - w)   0 [BX] BX MOV        NEXT C;
CODE ! ( w a)     0 [BX] POP  BX POP   NEXT C;

CODE C@ ( a - b)  0 [BX] BL MOV   BH BH SUB        NEXT C;
CODE C! ( b a)    AX POP  AL 0 [BX] MOV   BX POP   NEXT C;

CODE CMOVE ( a a2 u)
\ move count bytes from from to to, leftmost byte first.
   BX CX MOV   SI BX MOV   DI POP  SI POP
   REP BYTE MOVS   BX SI MOV   BX POP   NEXT C;

SCREEN 11
\ Math operators
| CODE tic   NOP
| CODE lit   WORD LODS   BX PUSH  AX BX MOV    NEXT C;
\ push the following (in-line) number onto the stack.

CODE + ( n n2 - n3)   AX POP  AX BX ADD            NEXT C;
CODE - ( n n2 - n3)   AX POP  AX BX SUB   BX NEG   NEXT C;

CODE NEGATE ( n -  n2)   BX NEG   NEXT C;
CODE ABS    ( n - +n2)
   BX BX OR  1 L# JNS   BX NEG   1 L: NEXT C;

CODE +! ( n a)   AX POP   AX 0 [BX] ADD  BX POP   NEXT C;
\ increment number at address by n.

SCREEN 12
\ Math and logical
CODE 1+ ( n - n2)   BX INC   NEXT C;
CODE 1- ( n - n2)   BX DEC   NEXT C;

CODE 2* ( n - n2)   BX SHL   NEXT C;  { CONTROLLED} { Require?}
CODE 2/ ( n - n2)   BX SAR   NEXT C;  ( arithmetic)

CODE AND ( m m2 - m3)   AX POP  AX BX AND    NEXT C;
CODE OR  ( m m2 - m3)   AX POP  AX BX OR     NEXT C;
CODE XOR ( m m2 - m3)   AX POP  AX BX XOR    NEXT C;

CODE NOT ( w - w2)   BX NOT   NEXT C;  { ( m - m2) ?}

SCREEN 13
\ Comparisons
CODE 0 ( - n)      BX PUSH   BX BX SUB    NEXT C;  { Feature}
CODE 1 ( - n)      BX PUSH   1 # BX MOV   NEXT C;  { Feature}
CODE TRUE ( - m)   BX PUSH  -1 # BX MOV   NEXT C;  { Control?}

CODE = ( n n2 - f)   AX POP  AX BX CMP
   TRUE # BX MOV  1 L# JZ   BX INC   1 L: NEXT C;

CODE <  ( n n2 - f)   AX POP  BX AX SUB
   TRUE # BX MOV  1 L# JL   BX INC   1 L: NEXT C;
CODE U< ( u u2 - f)   AX POP  BX AX SUB
   TRUE # BX MOV  1 L# JB   BX INC   1 L: NEXT C;

: > ( n n2 - f)   SWAP < ;

SCREEN 14
\ Comparisons against zero and CELL operators
CODE 0= ( n - f)
   BX BX OR  TRUE # BX MOV  1 L# JZ   BX INC   1 L: NEXT C;
CODE 0< ( n - f)
   BX BX OR  TRUE # BX MOV  1 L# JS   BX INC   1 L: NEXT C;

: 0> ( n - f)   0 > ;


2 CONSTANT CELL  { Feature}

CODE CELL+ ( a - a2)   BX INC  BX INC   NEXT C;
CODE CELLS ( a - a2)   BX SHL           NEXT C;

SCREEN 15
\ Branches and loops
| CODE  branch         \ unconditional branch.
   0 [SI] SI MOV   NEXT C;
| CODE ?branch ( f)    \ branch if zero.
   BX BX OR  BX POP    ' branch JZ   2 # SI ADD   NEXT C;

| CODE (do) ( n n2)    \ begin DO...LOOP structure.
   4 # BP SUB      AX POP   HEX 8000 DECIMAL # AX ADD
   AX 2 [BP] MOV   AX BX SUB   BX 0 [BP] MOV   BX POP   NEXT C;

| CODE (loop)         \ terminate DO...LOOP structure.
   WORD 0 [BP] INC  ' branch JNO
LABEL  >loop   2 # SI ADD
| CODE >undo   4 # BP ADD   NEXT
| CODE (+loop) ( n)   \ terminate DO...+LOOP structure.
   BX 0 [BP] ADD  BX POP  ' branch JNO  >loop JO   NEXT C;

SCREEN 16
\ Return stack
CODE >R ( w)    BP DEC  BP DEC  BX 0 [BP] MOV   BX POP  NEXT C;

CODE R@ ( - w)  BX PUSH  0 [BP] BX MOV   NEXT C;
CODE I  ( - n)  BX PUSH  0 [BP] BX MOV  2 [BP] BX ADD   NEXT C;
CODE J  ( - n)  BX PUSH  4 [BP] BX MOV  6 [BP] BX ADD   NEXT C;
CODE R> ( - w)  BX PUSH  0 [BP] BX MOV  BP INC  BP INC  NEXT C;

CODE 2>R ( w w2)
\ push w and w2 to the return stack, w2 on top.
   4 # BP SUB   BX 0 [BP] MOV   2 [BP] POP   BX POP     NEXT C;

CODE 2R> ( - w w2)
\ pop w and w2 from the return stack.
   BX PUSH   2 [BP] PUSH   0 [BP] BX MOV   4 # BP ADD   NEXT C;

SCREEN 17
\ Optimizations and EXECUTE
CODE NIP  ( w w2 - w2)       { CONTROLLED}  AX POP   NEXT C;
CODE TUCK ( w w2 - w2 w w2)  { CONTROLLED}  AX POP
   BX PUSH  AX PUSH   NEXT C;

CODE ?DUP ( w - w w | 0 - 0)
   BX BX OR  1 L# JZ   BX PUSH  1 L: NEXT C;

CODE EXECUTE ( w)   BX AX XCHG   BX POP   AX JMP C;

CODE @EXECUTE ( w)  { Control?}  { Why w and not a?}
\ @EXECUTE is equivalent to @ EXECUTE but is much faster.
   BX DI MOV   BX POP   0 [DI] AX MOV   AX JMP C;

SCREEN 18



SCREEN 19
\ ------ Input/Output -----------------------------
\ In ZEN, consecutive headerless variables form a category
\ which can be extended but not reduced or reordered.

0 USER entry  2 CELLS + ( skip multitasking hooks)
  USER r      | USER SP0
  USER x      \ XFER vector pointer.
  USER BASE   | USER dpl    | USER hld   EQU #I/0

: THERE ( - a)   r @ ;  { ROM}
: PAD   ( - a)   r @ [ #Jot ] LITERAL + ;  { CONTROLLED}
{ pictured number staging area size undefined?}

: DECIMAL   10 BASE ! ;
: HEX       16 BASE ! ;  { CONTROLLED}

SCREEN 20
\ Double-value data stack operators
CODE 2DUP ( w w2 - w w2 w w2)   SP DI MOV   BX PUSH
   0 [DI] PUSH   NEXT C;

CODE 2DROP ( w w2)   BX POP  BX POP   NEXT C;

CODE 2SWAP ( w w2 w3 w4 - w3 w4 w w2)   AX POP  CX POP  DX POP
   AX PUSH  BX PUSH  DX PUSH  CX BX MOV   NEXT C;

: 2OVER ( d d2 - d d2 d)       2>R 2DUP  2R> 2SWAP ;
: 2ROT  ( d d2 d3 - d2 d3 d)   2R> 2SWAP 2R> 2SWAP ;
{ CONTROLLED}  { Require?}

CODE 2@ ( a - w w2)   2 [BX] PUSH  0 [BX] BX MOV        NEXT C;
CODE 2! ( w w2 a)     0 [BX] POP   2 [BX] POP   BX POP  NEXT C;

SCREEN 21
\ Numeric conversion math support
CODE D+ ( d d2 - d3)   AX POP   DX POP   CX POP
   AX CX ADD   CX PUSH    DX BX ADC   NEXT C;

CODE DNEGATE ( d - d2)   AX POP  AX NEG  AX PUSH
   0 # BX ADC   BX NEG   NEXT C;

: MAX ( n n2 - n3)   2DUP <    IF  SWAP  THEN  DROP ;
: MIN ( n n2 - n3)   2DUP < 0= IF  SWAP  THEN  DROP ;


SCREEN 22
\ Numeric conversion math support
CODE UM* ( u u2 - ud)
   AX POP   BX MUL    AX PUSH   DX BX MOV   NEXT C;

CODE UM/MOD ( ud u - u2 u3)
\ return rem u2 and quot u3 of unsigned ud divided by u.
\ On zero-divide, return quot=0 and rem=low-word-of-ud.
   DX POP  AX AX SUB  BX DX CMP  1 L# JAE
   AX POP  BX DIV  DX PUSH       1 L: AX BX MOV   NEXT C;


SCREEN 23
\ Input number conversion
ASCII A  ASCII 9  1+ - EQU A-10

| : digit ( c base - n t | ? 0)
\ true if the char c is a valid digit in the given base.
   SWAP [ASCII] 0 -  9 OVER <  DUP
   IF  DROP  A-10 -  10  THEN
   >R  DUP R@ -  ROT R> -  U< ;

: CONVERT ( +d a - +d2 a2)
\ convert the char sequence at a+1 and accumulate it in +d.
\ a2 is the address of the first non-convertable digit.
   BEGIN  1+ DUP >R  C@ BASE @ digit
   WHILE  SWAP  BASE @ UM* DROP  ROT  BASE @ UM*  D+  R>
   REPEAT DROP  R> ;

SCREEN 24
\ Output number conversion
: <#   PAD hld ! ;
: #> ( wd - a u)   2DROP hld @ PAD OVER - ;

: HOLD ( c)   TRUE hld +!  hld @ C! ;
\ add character c to output string.
: SIGN ( n)   0< IF  [ASCII] - HOLD  THEN ;
\ add "-" to output string if w is negative.

: # ( ud - ud2)
\ transfer the next digit of ud to the output string.
   BASE @ >R  0 R@ UM/MOD  R> SWAP >R  UM/MOD  R>
   ROT 9 OVER < IF  A-10 + THEN  [ASCII] 0 + HOLD ;

: #S ( ud - ud2)   BEGIN  #  2DUP OR  0= UNTIL ;
\ convert all remaining digits of ud.  ud2 is 0 0 .

SCREEN 25
\ Transfers
LABEL xvar  \ the action of all transfers.
   u ) DI MOV   x [DI] DI MOV   3 # AX ADD   DI AX XCHG
   0 [DI] DI MOV   AX DI ADD   0 [DI] AX MOV   AX JMP C;

0 XFER TYPE ( a u)              XFER CR
  XFER KEYS ( a u) { Private}   XFER KEY? ( - f) { Extend?}
  XFER MARK ( a u) { Extend?}   XFER PAGE        { Extend?}
  XFER TAB ( n n2) { Extend?} ( Reserved)  DROP

\ KEYS is a simple unfiltered EXPECT which doesn't echo.
\ KEY? is true if a key is available.
\ MARK is like TYPE but highlights if possible.
\ PAGE clears the screen.
\ TAB  moves the cursor to the x (n) and y (n2) coordinates.

SCREEN 26
\ Print spaces
32 CONSTANT BL  { CONTROLLED}   \ ASCII blank

     HERE ( *) BL ,
: SPACE   ( *) LITERAL 1 TYPE ;

HERE ( * )  BL C, BL C, BL C, BL C, BL C, BL C, BL C, BL C,
: SPACES ( +n )  \ output w spaces.   Optimized for TYPE.
   ( * ) LITERAL  OVER 2/ 2/ 2/  ?DUP
   IF  0 DO  DUP 8 TYPE  LOOP  THEN  SWAP 7 AND TYPE ;

SCREEN 27
\ Print numbers
| : (d.) ( d - a u)   \ convert a double number to a string.
   TUCK  DUP 0< IF  DNEGATE  THEN  <#  #S ROT SIGN  #> ;

: D. ( d)   (d.) TYPE SPACE ;
: U. ( u)        0 D. ;
:  . ( n)   DUP 0< D. ;

SCREEN 28

SCREEN 29
\ ------ Interpreter ------------------------------
#I/O ( continued from I/O layer)
  USER BLK  { BLOCK} { Require?}   USER >IN   \ keep together.
  USER #TIB   CELL+   \ #TIB and TIB's value.
  USER SPAN
  USER STATE  EQU #Used

  VARIABLE last   CELL ALLOT     \ last lfa and cfa.
| VARIABLE scr    CELL ALLOT     \ last error location.
| VARIABLE bal  | VARIABLE leaf  \ see compiler.

VARIABLE CONTEXT  { CONTROLLED}
VARIABLE CURRENT  { CONTROLLED}

: TIB ( - a)   #TIB CELL+ @ ;

SCREEN 30
\ Automatic variables
\ These variables are automatically initialized; see COLD.
VARIABLE h   | VARIABLE f   CELL ( ie vlink) ALLOT

  VARIABLE 'pause    \ multitasking hook.
| VARIABLE 'expect   \ deferred EXPECT
| VARIABLE 'source   \ deferred input stream.
| VARIABLE 'warn     \ redefinition warning.
| VARIABLE 'loc      \ source location field.
| VARIABLE 'val?     \ string to number conversion.

| VARIABLE key'  CELL ALLOT   \ one-key look-ahead buffer.

: HERE ( - a)   h @ ;

SCREEN 31
( String operators-- high-level definitions )  EXIT
: COUNT ( a - a2 u)   DUP C@ SWAP 1+ ;
\ transform counted string into text string.
: /STRING ( a u n - a2 u2)  { Control?}  ROT OVER + ROT ROT - ;
\ truncate leftmost n chars of string.  n may be negative.

: SKIP ( a u b - a2 u2)  { Control?}
\ return shorter string from first position unequal to byte.
   >R  BEGIN  DUP
       WHILE  OVER C@ R@ - IF  R> DROP  EXIT  THEN  1 /STRING
       REPEAT   R> DROP ;
: SCAN ( a u b - a2 u2)  { Control?}
\ return shorter string from first position equal to byte.
   >R  BEGIN  DUP
       WHILE  OVER C@ R@ =  IF  R> DROP  EXIT  THEN  1 /STRING
       REPEAT   R> DROP ;

SCREEN 32
( String operators-- low-level definitions )
CODE COUNT ( a - a2 u)   BX AX MOV   AX INC
\ transform counted string into text string.
   0 [BX] BL MOV   BH BH SUB   AX PUSH   NEXT C;
CODE /STRING ( a u n - a2 u2)  { Control?}  CX POP  AX POP
\ truncate leftmost n chars of string.  n may be negative.
   BX AX ADD  BX CX SUB   CX BX MOV   AX PUSH   NEXT C;

CODE SKIP ( a u b - a2 u2) { Contr?}  BX AX MOV  CX POP  DI POP
\ return shorter string from first position unequal to byte.
   1 L# JCXZ   REPE BYTE SCAS    1 L# JZ    CX INC  DI DEC
   1 L: DI PUSH  CX BX MOV   NEXT C;
CODE SCAN ( a l b - a2 u2) { Contr?}  BX AX MOV  CX POP  DI POP
\ return shorter string from first position equal to byte.
   1 L# JCXZ   REPNE BYTE SCAS   1 L# JNZ   CX INC  DI DEC
   1 L: DI PUSH  CX BX MOV   NEXT C;

SCREEN 33
\ More string operators
CODE FILL ( a u b)   \ store u b's, starting at addr a.
   BX AX MOV  CX POP  DI POP   REP BYTE STOS   BX POP   NEXT C;

: -TRAILING ( a +n - a2 +n2)   2DUP
\ alter string to suppress trailing blanks.
   BEGIN  2DUP         BL SKIP  DUP
   WHILE  2SWAP 2DROP  BL SCAN  REPEAT  2DROP  NIP - ;

EXIT
: FILL ( a u b)   \ store u b's, starting at addr a.
   SWAP ?DUP 0= IF  2DROP EXIT  THEN
   >R OVER C!  DUP 1+ R> 1- CMOVE ;

SCREEN 34
\ Input stream operators
| : source ( - a u)   #TIB 2@ ;   \ input stream source.
:  /source ( - a u)   'source @EXECUTE  >IN @ /STRING ;

| : accept ( n f)   IF  1+  THEN  >IN +! ;
\ accept characters by incrementing >IN.

: parse ( c - a u)   \ parse a character-delimited string.
   >R  /source  OVER SWAP  R> SCAN  >R  OVER -  DUP R> accept ;

: WORD ( c - a)      \ parse a character-delimited string;
\ leading delimiters are accepted and skipped;
\ the string is counted and followed by a blank (not counted).
   >R  /source  OVER R> 2>R  R@ SKIP  OVER SWAP  R> SCAN
   OVER R> -  SWAP accept  OVER -  31 MIN  THERE  DUP >R
   2DUP C!  1+ SWAP CMOVE  BL R@ COUNT + C!  R> ;

SCREEN 35
\ Dictionary search
CODE thread ( a w - a 0 , cfa -1 , cfa 1)
\ search vocabulary for a match with the packed name at  a .
   DX POP  SI PUSH
 1 L: 0 [BX] BX MOV                ( chain thru dictionary )
   BX BX OR  5 L# JZ               ( jump if end of thread )
   DX DI MOV  ( 'string)   BX SI MOV  2 # SI ADD   ( SI=nfa)
   0 [SI] CL MOV     31 # CX AND   0 [DI] CL CMP   ( count = ?)
   1 L# JNZ ( lengths <>) DI INC  SI INC  ( to body of 'string)
   REPE BYTE CMPS ( names =?)  1 L# JNZ   ( jump not matched)
   CX POP   SI PUSH  ( cfa )
   CX SI MOV   BYTE 32 # 2 [BX] TEST  ( immediate bit )
   TRUE # BX MOV  4 L# JZ   BX NEG     4 L: NEXT
 5 L: SI POP   DX PUSH ( 'str)  ( BX = 0)   NEXT C;

SCREEN 36
\ FIND  [ and ]
: FIND ( a - a 0 | a - w -1 | a - w 1)
\ search dictionary for a match with the packed name at  a .
\ Return execution address and -1 or 1 ( IMMEDIATE) if found;
\ ['] EXIT 1 if  a  has zero length;  a 0  if not found.
   DUP C@ ( a l) DUP
   IF  31 MIN OVER C! ( a) CONTEXT @ thread ( a -1/0/1) DUP
      IF  EXIT  THEN       CONTEXT @ f -
      IF  DROP  f thread  THEN   EXIT
   THEN ( a 0) 2DROP  ['] EXIT 1 ;

: ]  TRUE STATE ! ;  \ stop interpreting; start compiling.
: [     0 STATE ! ;  \ stop compiling; start interpreting.
  IMMEDIATE

SCREEN 37
\ Data and return stack
\ Set data and return stack pointers, respectively:
| CODE sp! ( a)   BX SP MOV  BX POP   NEXT C;
| CODE rp! ( a)   BX BP MOV  BX POP   NEXT C;

: RESET  { Feature}  \ reset return stack for error recovery.
   I>  entry CELL - rp!  >I ;
: PRESET { Feature}  \ empty both stacks and prepare system.
   SP0 @ sp!  I> entry rp! >I  SP0 @ 0 #TIB 2!  0 STATE ! ;

| : err   RESET ;

CODE DEPTH ( - n)   \ # items on stack before DEPTH is executed.
   BX PUSH   u ) BX MOV   SP0 [BX] BX MOV   SP BX SUB   BX SAR
   NEXT C;

SCREEN 38
( Memory management-- high-level definitions)  EXIT
: ALLOT ( n)   r +! ;   \ allocate n RAM data bytes.
: GAP   ( n)   h +! ;   \ allocate n dictionary bytes.  { ROM}

: C, ( w)   h @ C!  1 h +! ;     \ ie  HERE C!  1 GAP ;
\ append low byte of w onto the dictionary.
: ,  ( w)   h @ !  CELL h +! ;   \ ie  HERE !  CELL GAP ;
\ append w onto the dictionary.

EXIT  { In an all-RAM system:}
: GAP   ALLOT ;   : THERE   HERE ;    : >DATA   >BODY ;
: GOES>  [COMPILE] DOES> ;  IMMEDIATE

SCREEN 39
( Memory management-- low-level definitions)
CODE ALLOT ( n)   \ allocate n RAM data bytes.
   r # DI MOV   u ) DI ADD   BX 0 [DI] ADD  BX POP   NEXT C;
CODE GAP   ( n)   \ allocate n dictionary bytes.  { ROM}
   h # DI MOV                BX 0 [DI] ADD  BX POP   NEXT C;

CODE C, ( w)   h # DI MOV   0 [DI] DI MOV
\ append low byte of w onto the dictionary.
   BL 0 [DI] MOV   1 # BX MOV  ' GAP JU
CODE ,  ( w)   h # DI MOV   0 [DI] DI MOV
\ append w onto the dictionary.
   BX 0 [DI] MOV   2 # BX MOV  ' GAP JU  FORTH

SCREEN 40
\ Code and data fields
: >BODY ( w - a)   3 + ;
: >DATA ( w - a)   3 + @ ;  { ROM}

: >code ( cfa - 'code)  1+  DUP @ CELL+ + ;
\ finds code address associated with cfa.
| : alter ( 'code cfa)   1+  TUCK CELL+ -  SWAP ! ;
\ point the cf to the given code addr.  Skip the CALL byte.

| : nest, ( 'code )   HERE  232 ( CALL) C,  CELL GAP  alter ;
\ create the code field for colon words, DOES> and GOES>
| : code, ( 'code )   HERE  233 ( JMP ) C,  CELL GAP  alter ;
\ create the code field for data words.

: patch ( 'code cfa)   233 ( JMP ) OVER C!  alter ;
\ make 'code the new action of the cf.  Used by (;code).

SCREEN 41
\ Alignment, string and error primitives
\ : ALIGN   HERE 1 AND GAP ;           { ALIGN}
\ force dictionary to the next even address.
\ : REALIGN ( a - a2)   DUP 1 AND + ;  { ALIGN}
\ force address to the next even address.

| : (") ( - a l)   I> COUNT  2DUP +  ( REALIGN) >I ;
\ leave the address and length of an in-line string.

| : huh? ( w)   0= ABORT" ?" ;
\ error action of several words.

: ' ( - w)   BL WORD  DUP C@ huh?  FIND huh? ;

\ : I>   [COMPILE] R> ;  IMMEDIATE  { ALIGN}
\ : >I   [COMPILE] >R ;  IMMEDIATE  { ALIGN}

SCREEN 42


SCREEN 43
\ ------ Compiler ---------------------------------
: COMPILE   I>  DUP CELL+ >I  @ , ;
\ compile the word that follows in the definition.

: header  \ create link and name fields.
   ( ALIGN)              'loc  @EXECUTE  ( extra fields )
   BL WORD  DUP C@ huh?  'warn @EXECUTE  ( redefinition?)
   HERE last !  HERE CURRENT @ DUP @ , ! ( link field)
   HERE OVER C@ 1+ CMOVE                 ( name field)
   HERE C@ DUP 128 OR C, GAP   HERE last CELL+ ! ;

SCREEN 44
\ Defining words
: CREATE ( - a)
   header  [ addr ] LITERAL code, ;

: VARIABLE ( - a)
   header  [ con ] LITERAL code,  THERE ,
   0 THERE ! ( courtesy )  CELL ALLOT ;

: CONSTANT ( - w)
   header  [ con ] LITERAL code,  , ;

SCREEN 45
\ DOES> and GOES>
| : (;code)   I> last CELL+ @ patch ;
\ the code field of (;code) is at  ' DOES> >BODY CELL+


: DOES>   COMPILE (;code)  [ (does) ] LITERAL nest, ; IMMEDIATE
\ eg  : KONST   CREATE  ,  DOES> @ ;

: GOES>  { ROM}  [COMPILE] DOES>  COMPILE @ ;  IMMEDIATE
\ eg  : VALUE   VARIABLE   GOES> @ ;

SCREEN 46
\ Literals
: LITERAL ( - w)     COMPILE lit  , ;  IMMEDIATE
\ compile w as a literal.
: [']     ( - w)  '  COMPILE tic  , ;  IMMEDIATE
\ compile-form of ' ("tick").

:  ASCII  ( - c)   BL WORD 1+ C@ ;  \ return value of next char.
: [ASCII] ( - c)                   \ compile value of next char.
   ASCII  [COMPILE] LITERAL ;  IMMEDIATE

: STRING ( c)  { Feature}  \ string compiler, eg 32 STRING ABC
   parse  DUP C,  HERE OVER GAP  SWAP CMOVE  ( ALIGN) ;

: " ( - a u)    \ string literal, eg " cccc"
   COMPILE (")  [ASCII] " STRING ;  IMMEDIATE
: ."   [COMPILE] "  COMPILE TYPE ;  IMMEDIATE

SCREEN 47
\ Flow of control
| : ?bal   DUP bal @ < huh?  PICK @ 0= huh? ;
| : -bal   bal @ huh?  TRUE bal +!  DUP @ huh? ;

: BEGIN  HERE  1 bal +! ;                          IMMEDIATE

: IF     COMPILE ?branch  [COMPILE] BEGIN   0 , ;  IMMEDIATE
: THEN   0 ?bal  TRUE bal +!  HERE SWAP ! ;        IMMEDIATE
: ELSE   0 ?bal  COMPILE  branch  [COMPILE] BEGIN  0 ,
         SWAP   [COMPILE] THEN ;                   IMMEDIATE

: UNTIL  -bal  COMPILE ?branch  , ;                IMMEDIATE
: AGAIN  -bal  COMPILE  branch  , ;  { Control?}   IMMEDIATE
: WHILE   bal @ huh?  [COMPILE] IF  SWAP ;         IMMEDIATE
: REPEAT  1 ?bal  [COMPILE] AGAIN [COMPILE] THEN ; IMMEDIATE

SCREEN 48
\ Definite loops
: DO   COMPILE (do)  [COMPILE] BEGIN ;   IMMEDIATE

: LEAVE  COMPILE >undo  COMPILE branch
   HERE  leaf @ , leaf ! ;               IMMEDIATE

| : rake,   \ gathers leaf's.  Courtesy of Wil Baden.
   DUP ,  leaf @
   BEGIN  2DUP U< WHILE  DUP @ HERE ROT !  REPEAT
   leaf ! DROP ;

:  LOOP  -bal  COMPILE  (loop)  rake, ;  IMMEDIATE
: +LOOP  -bal  COMPILE (+loop)  rake, ;  IMMEDIATE

: UNDO   COMPILE >undo ;  IMMEDIATE

SCREEN 49
\ Colon definitions
: :   \ create a word and enter the compiling loop.
   CURRENT @ CONTEXT !
   header  [ colon ] LITERAL nest,
   last @ @ CONTEXT @ !  0 0 bal 2!  ] ;

: ;   \ terminate a definition.
   bal 2@ OR ABORT" Unbalanced"
   last @ CURRENT @ !
   COMPILE semi [COMPILE] [ ;  IMMEDIATE

SCREEN 50
\ Vocabularies
: FORTH   f CONTEXT ! ;

: DEFINITIONS   CONTEXT @ CURRENT ! ;
\ new definitions will be into the CURRENT vocabulary.

: VOCABULARY
\ when executed, a vocabulary becomes first in the search order.
   VARIABLE   HERE  f CELL+ ( ie vlink) DUP @ , !
   CELL GAP ( value for automatic initialization)
   GOES> CONTEXT ! ;

SCREEN 51
\ Misc. compiler support
: IMMEDIATE   last @ CELL+  DUP C@ BL ( ie 32) OR SWAP C! ;

: [COMPILE]    ' , ;  IMMEDIATE
\ force compilation of an otherwise immediate word.

:  (   [ASCII] ) parse  2DROP ;  IMMEDIATE   ( comments)
: .(   [ASCII] ) parse   TYPE ;  IMMEDIATE   \ messages.

: RECURSE   last CELL+ @ , ;  IMMEDIATE   \ self-reference.

SCREEN 52
( Hall of fame--  high-level)  EXIT
: M+ ( d n - d2)  { Control?}  S>D D+ ;   \ add n to d.

: >< ( u - u2)  { Control?}  DUP 255 AND  SWAP 256 * OR ;
\ reverse the bytes within a cell.

: WITHIN ( u n n2 - f)  { Control?}  OVER - >R - R> U< ;
\ true if n <= u < n2  given circular comparison.

: ERASE ( a u)    0 FILL ;  { CONTROLLED}
: BLANK ( a u)   BL FILL ;  { CONTROLLED}

SCREEN 53
( Hall of fame--  low-level)
CODE M+ ( d n - d2)           { Control?}  \ add n to d.
   BX AX XCHG  CWD   BX POP  CX POP  AX CX ADD  CX PUSH
   DX BX ADC   NEXT C;

CODE >< ( u - u2)  { Control?}  BL BH XCHG   NEXT C;
\ reverse the bytes within a word.

: WITHIN ( u n n2 - f)  { Control?}  OVER - >R - R> U< ;
\ true if n <= u < n2  given circular comparison.

: ERASE ( a u)    0 FILL ;  { CONTROLLED}
: BLANK ( a u)   BL FILL ;  { CONTROLLED}

SCREEN 54
\ Byte move operators
: CMOVE> ( a a2 u)  { CONTROLLED}
\ move u bytes from a to a2, rightmost byte first.
   DUP DUP  >R  D+ R>  ?DUP
   IF  0 DO  1- SWAP 1-  TUCK C@ OVER C!  LOOP THEN 2DROP ;

: MOVE ( a a2 u)   \ move u bytes from a to a2 without overlap.
   >R  2DUP U< IF  R> CMOVE>  ELSE  R> CMOVE  THEN ;

: ROLL ( w[u] w[u-1]...w[0] u - w[u-1]...w[0] w[u])
\ rotate kth item to top of stack.  { Delete?}
   DUP  BEGIN  ?DUP WHILE  ROT >R      1- REPEAT
        BEGIN  ?DUP WHILE  R> ROT ROT  1- REPEAT ;

SCREEN 55
( Double-number math-- high-level)  EXIT
: S>D ( n - d)   DUP 0< ;           \ extend n to d.
: D>S ( d - n)   DROP ;  { DOUBLE}  \ truncate d to n.
{ Require?}

: D- ( d d2 - d')   DNEGATE D+ ;  { DOUBLE}

: D2* ( d - d*2)   2DUP D+ ;
: D2/ ( d - d/2)   SWAP 2/ 32767 AND         { DOUBLE}
   OVER 1 AND IF  32768 OR  THEN  SWAP 2/ ;  { Require?}

SCREEN 56
( Double-number math-- low-level)
CODE S>D ( n - d)   \ extend n to d.
   BX AX XCHG  CWD  AX PUSH  BX DX XCHG   NEXT C;
CODE D>S ( d - n)   BX POP  NEXT C;  { Req?}  \ truncate d to n.

CODE D- ( d d2 - d3)   BX DX MOV  AX POP  BX POP  CX POP
   AX CX SUB  CX PUSH  DX BX SBB   NEXT C;   { DOUBLE}

CODE D2* ( d - d2)
   AX POP   AX SHL  BX RCL   AX PUSH   NEXT C;
CODE D2/ ( d - d2)  { DOUBLE}  { Require?}
   AX POP   BX SAR  AX RCR   AX PUSH   NEXT C;

SCREEN 57
\ More Double-number math
: D<  ( d d2 - f)
   ROT 2DUP = IF  2DROP U< EXIT THEN  2SWAP 2DROP > ;

: D0= ( d - f)         OR 0= ;    { DOUBLE}
: D=  ( d d2 - f)   D- OR 0= ;    { DOUBLE}

: DABS ( d - ud)   DUP 0< IF  DNEGATE  THEN ;  { Double?}

: DMAX ( d d2 - dmax)  { DOUBLE}
   2OVER 2OVER D<     IF 2SWAP THEN  2DROP ;
: DMIN ( d d2 - dmin)  { DOUBLE}
   2OVER 2OVER D< NOT IF 2SWAP THEN  2DROP ;

SCREEN 58
\ Double-number operators
: 2CONSTANT ( - w)   CREATE  , ,  DOES> 2@ ;
\ create a double constant.  { DOUBLE}
: 2VARIABLE ( - a)   VARIABLE  0 THERE ! CELL ALLOT ;
\ create a double variable.  { DOUBLE}

: D@ ( a - d)   2@ ;  { DOUBLE}
: D! ( d a )    2! ;  { DOUBLE}

: DLITERAL ( d ) ( - d)  { Double?}  \ compile d as a literal.
   SWAP [COMPILE] LITERAL [COMPILE] LITERAL ; IMMEDIATE

: D.R ( d n)  { DOUBLE}
\ print d right-justified in field of width n.
   >R  TUCK  DABS  <#  #S ROT SIGN  #>
   R>  OVER - 0 MAX SPACES  TYPE ;

SCREEN 59
( Mixed-precision multiply and divide-- high-level)  EXIT
: M* ( n n2 - d)  { Control?}
\ signed mixed-precision multiply.
   2DUP XOR >R  ABS SWAP ABS UM*  R> 0< IF NEGATE THEN ;

: M/MOD ( d n - rem quot)  { Control?}
\ signed rounded-down mixed-precision divide.
   2DUP XOR >R  OVER >R  ABS >R DABS R> UM/MOD
   SWAP R> 0< IF  NEGATE  THEN
   SWAP R> 0< IF  NEGATE  THEN ;

SCREEN 60
( Mixed-precision multiply and divide-- low-level)
CODE M* ( n n2 - d)  { Control?}
\ signed mixed-precision multiply.
   BX AX XCHG  DX POP   DX IMUL   AX PUSH  DX BX MOV   NEXT C;

CODE M/MOD ( d n - rem quot)  { Control?}  DX POP  AX POP
\ signed rounded-down mixed-precision divide.
   BX BX OR  5 L# JZ  ( divide by zero?)
   BX IDIV        AX BX MOV  DX PUSH   NEXT
 5 L: AX DX MOV  0 # BX MOV  DX PUSH   NEXT C;

SCREEN 61
( Mixed-precision multiply and divide-- floored)  EXIT
CODE M* ( n n2 - d)  { Control?}
\ signed mixed-precision multiply.
   BX AX XCHG  DX POP   DX IMUL   AX PUSH  DX BX MOV   NEXT C;

: M/MOD ( d n - rem quot)  { Control?}
\ signed floored mixed-precision divide.
   DUP >R  2DUP XOR >R  DUP >R  ABS >R DABS R> UM/MOD
   SWAP R> 0< IF  NEGATE  THEN
   SWAP R> 0< IF  NEGATE  OVER IF  R@ ROT -  SWAP 1-  THEN THEN
   R> DROP ;

SCREEN 62
\ Multiply and divide
: /MOD ( n n2 - n3 n4)   >R DUP 0< R> M/MOD ;

: /   ( n n2 - n3)   /MOD  NIP ;
: MOD ( n n2 - n3)   /MOD  DROP ;

\ Intermediate product is 32 bits:
: */MOD ( n n2 n3 - n4 n5)   >R M* R> M/MOD ;
: */    ( n n2 n3 - n4)      >R M* R> M/MOD  NIP ;

CODE * ( n n2 - n3)   AX POP  BX IMUL   AX BX MOV   NEXT C;

EXIT
: * ( n n2 - n3)   UM* DROP ;

SCREEN 63
\ Number conversion operator
| : val? ( a u - d 2 , n 1 , 0)
\ string to number conversion primitive.  True if d is valid.
\ Returns d if number ends in final '.' and sets dpl = 0
\ Returns n if no punctuation present   and sets dpl = 0<
   [ #Jot 1- ] LITERAL MIN  PAD 1- OVER -  TUCK >R  CMOVE
   BL PAD 1-  DUP dpl ! C!  0 0 R>
   DUP C@ [ASCII] - = DUP >R - 1-
   BEGIN  CONVERT  DUP C@  DUP [ASCII] : =
     SWAP [ASCII] , [ASCII] / 1+ WITHIN  OR
   WHILE  DUP dpl !  REPEAT  R> SWAP >R IF  DNEGATE  THEN
   PAD 1- dpl @ - 1- dpl !   R> PAD 1- = ( valid?)
   IF  dpl @ 0< IF DROP 1 ELSE 2 THEN  ELSE  2DROP 0  THEN ;

: VAL? ( a u - d 2 , n 1 , 0)  { Feature}  'val? @EXECUTE ;

SCREEN 64
\ Interpreter proper
| : val, ( ... w )
\ compiles the top w stack items as numeric literals.
   DUP BEGIN  ROT >R                1- ?DUP 0= UNTIL
       BEGIN  R> [COMPILE] LITERAL  1- ?DUP 0= UNTIL ;

: interpret  { Feature}  \ the text compiler loop.
   BEGIN  BL WORD  FIND  ?DUP
     IF    STATE @ =  ( Imm?) IF  ,  ELSE EXECUTE  THEN
     ELSE  COUNT VAL?  DUP huh?
           STATE @ IF  val,  ELSE  DROP  THEN
     THEN
   AGAIN ;

SCREEN 65
\ QUIT support
: EVALUATE ( a u)   \ evaluate a string.
   #TIB 2@ 2>R  #TIB 2!  BLK 2@ 2>R  0 0 BLK 2!  interpret
   2R> BLK 2!  2R> #TIB 2! ;

: EXPECT ( a +n)   'expect @EXECUTE ;

: QUERY  { CONTROLLED}
\ fill TIB from next line of input stream.
   0 0 BLK 2!  TIB 80 EXPECT  SPAN @ #TIB ! ;

: ok?   \ status check.
   D0 @ [ #Safe ] LITERAL -  HERE U< ABORT" No Room"
   DEPTH 0< ABORT" Stack?" ;

: OK?  { Feature}  ok?  STATE @ 0= IF ." ok" THEN ;

SCREEN 66
\ QUIT and ABORT
: QUIT   \ default main program.
   RESET  BEGIN  CR QUERY  SPACE interpret  OK?  AGAIN ;

: GRIPE ( a u)  { Feature}  \ default error handler.
   BLK @ IF  BLK 2@ scr 2!  THEN
   THERE COUNT TYPE SPACE  ( msg ) TYPE ;

: ABORT   BEGIN  PRESET QUIT  GRIPE  AGAIN ;
\ default main program and error handler, courtesy Wil Baden.

: ABORT"   \ compile error handler and message.
   [COMPILE] IF  [COMPILE] "  COMPILE err  [COMPILE] THEN ;
  IMMEDIATE

SCREEN 67
( Debug-- EXIT when done)
: .S  { Control?}  \ display the data stack.
   DEPTH 0 MAX  ?DUP
   CR  IF 0 DO  DEPTH I - 1- PICK  .  LOOP  THEN  ." <-Top " ;

: DUMP ( a u)  { RESERVED}  \ simple dump.
   SPACE 0 DO  DUP 7 AND 0= IF  SPACE  THEN  DUP C@ .  1+ LOOP
   DROP ;

: ? ( a)   @ . ;  { Control?}

: WORDS  { Control?}  \ simple word list.
   CONTEXT @
   BEGIN @ ?DUP
   WHILE  DUP CELL+ COUNT 31 AND TYPE SPACE  REPEAT ;

SCREEN 68
\ FORGET support
| : clip ( a 'lfa)   \ unlink words below the given address.
   BEGIN   DUP @
   WHILE  2DUP @  SWAP U< NOT ( ie U<= )
     IF    DUP @ @ OVER ! ( unlinks it )  ELSE  @  THEN
   REPEAT  2DROP ;

: crop ( lfa)
\ crop dictionary to the given link address.
   f CELL+ ( ie vlink)  2DUP clip
   BEGIN  @ ?DUP WHILE  2DUP CELL - @ ( ie >RAM) clip
   REPEAT  FORTH DEFINITIONS  DUP CURRENT @ clip  h ! ;

SCREEN 69
\ FORGET and variations
: GUARD   h H0 3 CELLS CMOVE  THERE T0 ! ;  { Feature}
: EMPTY   H0 h 3 CELLS CMOVE  T0 @  r  ! ;  { Feature}

: >link ( cfa - lfa)
   BEGIN  1- DUP C@ 128 AND UNTIL  CELL - ;

: FORGET   \ forget words from the following <name>.
   CURRENT @ CONTEXT !   ' >link
   DUP HERE H0 @ WITHIN ABORT" Can't"  crop ;
{ FORGET cannot recover RAM and so is not ROMable.}
{ Delete?}


SCREEN 70


SCREEN 71
\ ------ Device drivers ---------------------------
HEX
| CODE (type) ( a u)   BX CX MOV  DX POP   1 # BX MOV
   40 # AH MOV  21 INT   BX POP   'pause ) JMP C;

| CODE KDOS ( - key -1 , ? 0)
\ check for key pressed.
\ Special keys are returned in high byte with low byte zeroed.
   BX PUSH   FF # DL MOV   6 # AH MOV   21 INT
   0 # BX MOV  2 L# JE      AH AH SUB   ( special key?)
   AL AL OR    1 L# JNZ    7 # AH MOV   21 INT
   AH AH SUB   AL AH XCHG
 1 L: TRUE # BX MOV   2 L: AX PUSH   'pause ) JMP C;

SCREEN 72
\ KEY and EMIT actions
  13 EQU #EOL ( end-of-line)   10 EQU #LF  ( line-feed)
HERE EQU $Eol  #EOL C, #LF C,   2 EQU #Eol

| : (cr)   $Eol #Eol (type) ;

| : (key?) ( - f)   \ true if key pressed since last KEY.
   key' @ 0= IF  KDOS  key' 2!  THEN  key' @ ;

: KEY ( - n)   BEGIN  (key?) UNTIL  key' CELL+ @  0 key' ! ;
: EMIT ( b)   hld C!  hld 1 TYPE ;

SCREEN 73
\ EXPECT action
08   EQU #BSP ( backspace)    127 EQU #DEL ( delete)
27   EQU #ESC ( escape)
HERE EQU $Bsp ( * ) 3 C, #BSP C, BL C, #BSP C,

| : expect ( a +n)   >R  0  ( a o)
\ read upto +n chars into address; stop at #EOL or #ESC
   BEGIN  DUP R@ <
   WHILE  KEY 127 ( 7-bit ASCII) AND
     DUP #BSP =  OVER #DEL = OR
     IF    DROP  DUP IF  1-  $Bsp COUNT TYPE  THEN
     ELSE  DUP #EOL = OVER #ESC = OR
       IF  DROP  SPAN !  R> 2DROP  EXIT  THEN
       ( otherwise) BL MAX >R  2DUP +  R> OVER C!  1 TYPE  1+
     THEN
   REPEAT  SPAN !  R> 2DROP ;

SCREEN 74
\ Dumb terminal actions
| : (keys) ( a +n)   >R  0  ( a o)
\ read upto +n chars into address without echo; stop at #EOL
   BEGIN  DUP R@ <
   WHILE  KEY  DUP #EOL =
     IF  R> 2DROP  DUP >R  ( early out)
     ELSE  BL MAX >R  2DUP +  R> SWAP C!  1+  THEN
   REPEAT  SPAN !  R> 2DROP ;

| : (mark) ( a n)    ." ^"  TYPE ;
| : (page)   25 0 DO  CR  LOOP ;
| : (tab)  ( n n2)    CR  DROP SPACES ;

SCREEN 75
\ Initialize automatic variables
HERE EQU RAMs
] nope expect source nope nope  val? [
( key' ) 0 , 0 ,
HERE RAMs - EQU #RAMs


SCREEN 76


SCREEN 77
\ ------ Initialization ---------------------------
D0 CONSTANT parms   \ System parameter table.

CREATE glass        \ Simple transfer table.
] (type) (cr)  (keys) (key?)  (mark) (page)  (tab) nope [

: READY  ." Ready" ;  { Feature}  \ Initialize application.
: BYE    0 EXECUTE ;  { Feature}  \ Shut down  application.


SCREEN 78
\ Initialization-- high-level
160 CONSTANT VERSION  { Feature}  \ ZEN 1.60

| : vocabs   \ initialize vocabularies.
   f CELL+ ( ie vlink)
   BEGIN  @ ?DUP
   WHILE  DUP CELL+ @ OVER CELL - @ ( ie >RAM) !  REPEAT ;

| : cold   \ high-level coldstart initialization.
   TRUE ( wake) entry entry 2!  T0 2@ r 2!   glass x !
   RAMs 'pause #RAMs CMOVE
   EMPTY  vocabs  PRESET  FORTH DEFINITIONS  DECIMAL
   " READY" EVALUATE   ABORT ;

\ If all definitions are headerless, substitute:  READY  ABORT ;

SCREEN 79
\ Initialization-- low-level
HEX  HERE ( *) ," No Room $"

| CODE Coldstart   \ low-level initialization.
   1000 # BX MOV   4A # AH MOV   21 INT  ( enough room?)
 1 L# JNC  ( No:)
   ( *) 1+ # DX MOV   9 # AH MOV   21 INT   0 # JMP  ( Bye)
 1 L: #SP0 # SP MOV   #RP0 # BP MOV   BP u ) MOV
   ' cold >BODY # SI MOV  ( I register)   NEXT C;

HERE ( * ) Power ORG   ASSEMBLER  ' Coldstart # JMP C;
     ( * )       ORG


SCREEN 80

SCREEN 81
\ ------ FILE extension ---------------------------
#Used USER IO-RESULT  DROP

26  EQU #EOF  \ control-Z marks the end of older text files.

128 EQU buff  \ MS-DOS command tail and default fcb buffer.
192 EQU name  \ RENAME-FILE takes two names.

256  buff - EQU #buff   \ size of buffer in bytes.
name buff - EQU #name   \ size of name in bytes plus zero.

| : >fname ( a u - a2)   \ convert string to ASCIIZ file name.
   buff  2DUP 2>R  SWAP MOVE  R@  0 2R> + C! ;

SCREEN 82
\ MS-DOS interface
HEX
CODE fdos ( DX CX handle function# - AX)
\ generic call to MS-DOS
   BX AX MOV  BX POP  CX POP  DX POP   21 INT
LABEL return   AX BX MOV   1 L# JB   AX AX SUB   2 L# JZ
 1 L: BX BX SUB ( non-zero retcode forces zero result)
 2 L: u ) DI MOV   AX IO-RESULT entry - [DI] MOV   NEXT C;

| CODE rename ( a a2 function# - AX)
   BX AX MOV  DI POP  DX POP   21 INT   return JU C;

| CODE seek ( DX CX handle function# - AX DX)
   BX AX MOV  BX POP  CX POP  DX POP   21 INT
   DX PUSH   return JU C;

SCREEN 83
\ 5 file primitives
HEX
: OPEN-FILE   ( a u - w)   >fname  0 0 3D02 fdos ;
: CREATE-FILE ( a u - w)   >fname  0 0 3C00 fdos ;

: DELETE-FILE ( a u)   >fname  0 0 4100 fdos  DROP ;
: CLOSE-FILE  ( w)     0 0 ROT     3E00 fdos  DROP ;

: RENAME-FILE ( a u a2 u2)
   >fname  name #name CMOVE>
   >fname  name  5600 rename  DROP ;

SCREEN 84
\ Read, write and seek bytes
HEX
\ Read or write u bytes to or from address a to file w.
: READ-FILE  ( a u w - u2)   3F00 fdos ;
: WRITE-FILE ( a u w - u2)   4000 fdos ;

: SEEK-FILE ( doff n w - dpos)   \ add an offset to file w.
\ n neg: to start; n pos: to end; n zero: to current.
   SWAP DUP IF  0< CELLS 1+  THEN  4201 + seek ;

\ Return file position or size.
: FILEPOS  ( w - d)   >R  0 0 0 R> SEEK-FILE ;
: FILESIZE ( w - d)   >R  0 0 1 R> SEEK-FILE ;

SCREEN 85
\ Read and write lines of text
: WRITE-CR ( w)   $Eol #Eol ROT WRITE-FILE  DROP ;

: READ-LINE ( a u w - 0 0 | u2 t)
{ Greater performance will result if the end-of-line sequence  }
{ is read into the address and the size u adjusted accordingly.}
   >R  buff OVER 1+ #buff MIN R@ READ-FILE  ( a u u2)
   DUP 0= IF  R> 2DROP 2DROP  0 0 EXIT THEN ( end of file)
   buff OVER #EOL SCAN  NIP ( a u u2 u3)
   ?DUP IF   #Eol OVER - >R -
        ELSE  2DUP U< >R  THEN  MIN R> ( a u4 #seek)
   ?DUP IF  S>D 0 R@ SEEK-FILE 2DROP  THEN
   buff OVER #EOF SCAN  NIP -   ( remove if no control-Zs)
   R> DROP ( a u4) >R  buff SWAP R@ CMOVE>  R> TRUE ;

SCREEN 86
\ Load and save files
: GO ( a u)  { Feature}  \ evaluate the KERNEL.SRC file.
   " KERNEL.SRC" OPEN-FILE DUP huh?  ( w) >R
   BEGIN  buff  DUP 64 R@ READ-LINE
   WHILE  EVALUATE  REPEAT  2DROP   R> CLOSE-FILE ;

: SAVE-FILE ( a u)  { Feature}  \ save the dictionary by name.
   CREATE-FILE DUP huh?  ( w) >R
   'pause RAMs #RAMs CMOVE   GUARD   f CELL+ ( ie vlink)
   BEGIN  @ ?DUP ( save vocabularies)
   WHILE  DUP CELL - @ ( ie >RAM) @ OVER CELL+ !  REPEAT
   256  HERE OVER - R@ WRITE-FILE  DROP   R> CLOSE-FILE ;

SCREEN 87
\ BLOCK word set
VARIABLE system    VARIABLE block#    VARIABLE update
VARIABLE buffer  1024 CELL - ALLOT

: seek-block ( u w - a n w)
   >R  1024 UM* TRUE  R@ SEEK-FILE 2DROP  buffer 1024 R> ;

: SAVE-BUFFERS  { BLOCK}  system @ 0= ABORT" No File"
   system 2@ seek-block WRITE-FILE DROP ;

: BUFFER ( u - a)  { BLOCK}  >R  block# 2@  R@ - AND
   IF  SAVE-BUFFERS  THEN   0 R> block# 2!  buffer ;

: BLOCK  ( u - a)  { BLOCK}
   DUP block# @ = IF  DROP buffer  EXIT THEN
   BUFFER >R  system 2@ seek-block READ-FILE DROP  R> ;

SCREEN 88
\ BLOCK support
: EMPTY-BUFFERS  { CONTROLLED}  0 TRUE block# 2! ;

HEX
: UPDATE  { BLOCK}  TRUE update ! ;
: FLUSH   { BLOCK}
   SAVE-BUFFERS  0 0 system @ 4500 fdos  CLOSE-FILE ;

: LOAD ( u)  { BLOCK}
   BLK 2@ 2>R  0 SWAP BLK 2!  interpret  2R> BLK 2! ;

: block   BLK @ ?DUP IF  BLOCK 1024  ELSE  #TIB 2@  THEN ;

\ Use this definition if the BLOCK word set is compiled:
: READY   ." Ready!"    ['] block 'source !
   " NEW.SCR" OPEN-FILE  DUP huh?  system !  EMPTY-BUFFERS ;